home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / l2c-19.exe / QDIM.LSP < prev    next >
Lisp/Scheme  |  1993-06-25  |  15KB  |  498 lines
  1. ;;;QDIM v1.0    01.20.93
  2. ;;;by Raymond Bradley, CIS 71165,2764
  3. ;;;c/o Fitschen & Associates
  4. ;;;1855 Gateway Blvd., Ste 370
  5. ;;;Concord, CA  94520
  6. ;;;510 686 2400
  7.  
  8. (defun C:qdim ( / pt1 pt2 pt3 pt4 ftxt ptm ptp pth ptl ang num pt_c snlist
  9.      angp angl gd lalist la box aforc oaforc dlist oerr ed sd osnlist)
  10.  
  11.      (setup)
  12.      (if (not dcl_q) (setq dcl_q (load_dialog "QDIM")))
  13.  
  14.      (if (setq ss (ssget "I"))
  15.     (if (and (= (sslength ss) 1)
  16.         (= (dxf 0 (setq ed (entget (ssname ss 0)))) "DIMENSION"))
  17.         (setq P_QBSN T
  18.           P_QBPT (dxf 10 ed)
  19.           P_QBAN (angle P_QBPT (dxf 14 ed))
  20.         );setq
  21.     );if
  22.      );if
  23.  
  24.      (while (not (setq pt1 (getpoint "\nSelect first point: ")))
  25.       (setq sd 4)
  26.       (while (> sd 3)
  27.            (if (not (new_dialog "qdlist" dcl_q)) (exit))
  28.     (prep_tiles)
  29.         (setq sd (start_dialog))
  30.     (if (= sd 5) (base_pick))
  31.       );while
  32.       (grtext -1 (strcat "Layer: " (nth P_LIND lalist) "  Style: " (nth P_DIND dlist)))
  33.     );while
  34.  
  35.      (while (not (setq pt2 (getpoint pt1 "\nSelect second point: ")))
  36.       (setq sd 4)
  37.       (while (> sd 3)
  38.            (if (not (new_dialog "qdlist" dcl_q)) (exit))
  39.     (prep_tiles)
  40.         (setq sd (start_dialog))
  41.     (if (= sd 5) (base_pick))
  42.       );while
  43.       (grtext -1 (strcat "Layer: " (nth P_LIND lalist) "  Style: " (nth P_DIND dlist)))
  44.     );while
  45.  
  46.      (setq ptm (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))
  47.        pt_c pt2
  48.           angp (angle pt1 pt2)
  49.           angl (+ angp (* pi 0.5))
  50.           opt pt1 opta pt1 optb pt1
  51.           box 1
  52.      );setq
  53.  
  54.      (menucmd "p0=")
  55.  
  56.      (grdraw pt1 pt2 -1 3)
  57.  
  58.      (if (> (car pt1) (car pt2))
  59.           (setq ptp pt2 pt2 pt1 pt1 ptp)
  60.      );if
  61.  
  62.      (if (> (cadr pt2) (cadr pt1))
  63.           (setq  pth pt2 ptl pt1);setq
  64.           (setq  pth pt1 ptl pt2);setq
  65.      );if
  66.  
  67.      (setq pt3 (list (car pt1) (cadr pt2))
  68.            pt4 (list (car pt2) (cadr pt1))
  69.            gd (grread T 4 box)
  70.        oerr *error*
  71.      );setq
  72.  
  73.      (defun *error* (st)
  74.     (dmdraw pt1 opta ptb pt2)
  75.     (setq *error* oerr)
  76.     (grtext)
  77.     (princ)
  78.      );defun
  79.  
  80.      (prompt "\nWHITE button changes parameters")
  81.      (prompt "\nBLUE button to snap")
  82.      (prompt "\nLocate third point: ")
  83.  
  84.      (while (or (= (car gd) 5) (= (car gd) 2) (= (car gd) 6))
  85.           (cond
  86.                ((= (car gd) 6)
  87.                     (cond
  88.                          ((= (cadr gd) 0)
  89.                   (setq sd 4)
  90.                   (while (> sd 3)
  91.                                   (if (not (new_dialog "qdlist" dcl_q)) (exit))
  92.                       (prep_tiles)
  93.                                   (setq sd (start_dialog))
  94.                 (if (= sd 5) (base_pick))
  95.                   );while
  96.                               (grtext -1 (strcat "Layer: " (nth P_LIND lalist) "  Style: " (nth P_DIND dlist) "  Mode: " mode ftxt))
  97.                               (setq gd (grread T 4 box)) 
  98.                          );cond BUTTON 2
  99.  
  100.                          ((= (cadr gd) 1)
  101.                               (menucmd "p0=POP0")
  102.                               (menucmd "p0=*")
  103.                               (setq gd (grread))
  104.  
  105.                               (if (= (car gd) 4)
  106.                                    (progn
  107.                     (setq tx (nth (- (cadr gd) 500) snlist))
  108.                     (cond 
  109.                         ((wcmatch tx "*NEA*,*PER*,*TAN*")
  110.                         (prompt (strcat tx " to "))
  111.                         (setq box 2)
  112.                         )
  113.                         ((wcmatch tx "*CEN*,*ENDP*,*INS*,*INT*,*MID*,*NOD*,*QUA*")
  114.                         (prompt (strcat tx " of "))
  115.                         (setq box 2)
  116.                         )
  117.                         (T (prompt tx) (setq box 1))
  118.                     );cond
  119.                                    );progn
  120.                               );if
  121.                               (setq gd (grread T 4 box))
  122.                          );cond BUTTON 3
  123.  
  124.                     );cond within button pick
  125.                );cond menu button pick
  126.  
  127.                ((= (car gd) 2)
  128.                     (cond
  129.                          ((or (= (cadr gd) 13) (= (cadr gd) 32))
  130.                               (snapto)
  131.                          );cond
  132.  
  133.                          (T
  134.                               (setq tx (strcat tx (chr (cadr gd))))
  135.                               (prompt (chr (cadr gd)))
  136.                          );other keypress
  137.  
  138.                     );cond within in keypress
  139.                );cond keypress
  140.  
  141.                ((= (car gd) 5)     
  142.                     (setq ptp (cadr gd)
  143.                          ang (angle ptm ptp)
  144.                     );setq
  145.                );cond GET POINT
  146.           );cond overall
  147.  
  148.           (orient)
  149.           (qddraw)
  150.           (setq gd (grread T 4 box))
  151.      );while main
  152.  
  153.      (setq tx (strcase tx) *error* oerr)
  154.      (if (member tx snlist)
  155.           (progn
  156.                (setq ptm (osnap ptp tx))
  157.                (if ptm (setq ptp ptm))
  158.           );progn
  159.      );if
  160.  
  161.  
  162.      (cond
  163.           ((= mode "ALIGN")
  164.                (setq optb (distance pt1 pt2))
  165.           )
  166.  
  167.           ((= mode "HOR")
  168.                (setq optb (distance pt1 (list (car pt2) (cadr pt1))))
  169.           )
  170.  
  171.           ((= mode "VERT")
  172.                (setq optb (distance pt1 (list (car pt1) (cadr pt2))))
  173.           )
  174.      );cond
  175.  
  176.      (if (<= optb 48)
  177.           (setq optb (strcat (rtos optb 2 0) (chr 34)))
  178.           (setq optb (rtos optb))
  179.      );if
  180.  
  181.      (if (and (= (substr optb 1 2) "44") (= (ascii (substr optb 3 1)) 34))
  182.           (setq optb (strcat optb " CLR."))
  183.      );if
  184.  
  185.      (if (not (new_dialog "edit" dcl_q)) (exit))
  186.      (set_tile "word" optb)
  187.      (action_tile "plusminus" "(set_tile \"word\" (strcat \"%%P\" (get_tile \"word\")))")
  188.      (action_tile "min" "(set_tile \"word\" (strcat (get_tile \"word\") \" MIN.\"))")
  189.      (action_tile "clr" "(set_tile \"word\" (strcat (get_tile \"word\") \" CLR.\"))")
  190.      (action_tile "eq" "(set_tile \"word\" \"EQ.\")")
  191.      (action_tile "accept" "(setq optb (strcase (get_tile \"word\")))(done_dialog)")
  192.      (action_tile "word" "(mode_tile \"accept\" 2)")
  193.      (mode_tile "accept" 2)
  194.      (start_dialog)
  195.  
  196.      (dmdraw pt1 pta ptb pt2)
  197.      (setq  opt (getvar "CLAYER"))
  198.  
  199.      (command "LAYER" "S" (nth P_LIND lalist) "")
  200. ;     (if (not (tblsearch "STYLE" "ARCH"))
  201. ;          (command ".STYLE" "ARCH" "ARCHITXT" "" "" "" "" "" "")
  202. ;     );if
  203.  
  204.      (command "DIM")
  205.      (if (/= (nth P_DIND dlist) "*UNNAMED")
  206.     (command "RESTORE" (nth P_DIND dlist))
  207.      );if
  208.      (command "STYLE")
  209. ;    (command "ARCH")
  210.      (command "DIMSCALE" C_SCAL mode pt1 pt2)
  211.      (command ptp optb "E")
  212.      (if P_BFOL
  213.       (progn
  214.     (setq ed (entget (entlast))
  215.           P_QBPT (dxf 10 ed)
  216.           P_QBAN (angle P_QBPT (dxf 14 ed))
  217.           P_QBSN T
  218.     )
  219.       );progn
  220.      );if
  221.      (command "LAYER" "S" opt "")
  222.      (setvar "TEXTEVAL" te)
  223.      (setvar "LASTPOINT" pt_c)
  224.      (grtext)
  225.      (princ)
  226. );defun
  227.  
  228. (defun prep_tiles ()
  229.    (start_list "llist")
  230.    (mapcar 'add_list lalist)
  231.    (end_list)
  232.    (start_list "dlist")
  233.     (mapcar 'add_list dlist)
  234.     (end_list)
  235.     (set_tile "dlist" (itoa P_DIND))
  236.     (set_tile "llist" (itoa P_LIND))
  237.     (cond
  238.     ((= aforc 1)
  239.          (set_tile "aligned" "1")
  240.         )
  241.         ((= aforc 2)
  242.          (set_tile "horizontal" "1")
  243.         )
  244.         ((= aforc 3)
  245.          (set_tile "vertical" "1")
  246.         )
  247.        (T (set_tile "none" "1"))
  248.     );cond
  249.     (action_tile "accept" "(progn (force) (ddvals))")
  250.     (action_tile "cancel" "(done_dialog)")
  251.     (action_tile "pick" "(done_dialog 5)")
  252.     (if P_BFOL
  253.     (set_tile "follow" "1")
  254.     );if
  255.     (if P_QBSN
  256.     (set_tile "base" "1")
  257.     );if
  258.     (if (not P_QBPT)
  259.     (mode_tile "base" 1)
  260.     );if
  261. );defun
  262.  
  263. (defun ddvals ()
  264.      (setq d (get_tile "dlist")
  265.           l (get_tile "llist")
  266.      );setq
  267.      (if (/= d "")
  268.           (setq P_DIND (atoi d))
  269.      );if
  270.      (if (/= l "")
  271.           (setq P_LIND (atoi l))
  272.      );if
  273.      (if (= (get_tile "base") "1")
  274.     (setq P_QBSN T)
  275.     (setq P_QBSN nil)
  276.      );if
  277.      (if (= (get_tile "follow") "1")
  278.     (setq P_BFOL T)
  279.     (setq P_BFOL nil)
  280.      );if
  281.      (done_dialog)
  282. );defun
  283.  
  284. ;;;DMDRAW temporarily draws the guidelines on the screen
  285. ;;;issuing DMDRAW a second time with the same corrdinates will erase it
  286. (defun dmdraw (pt1 pt2 pt3 pt4)
  287.      (grdraw pt1 pt2 -1 3)
  288.      (grdraw pt2 pt3 -1)
  289.      (grdraw pt3 pt4 -1 3)
  290. );defun
  291.  
  292. (defun setup ( / num)
  293.      (setq te (getvar "TEXTEVAL")
  294.       C_SCAL (getvar "DIMSCALE")
  295.           aforc 0
  296.           tx ""
  297.           ftxt""
  298.       osnlist (list "NEA" "ENDP" "MID" "INTE" "PER" "CEN" "INS" "NOD" "QUA" "TAN")
  299.       fname (findfile (strcat (getvar "MENUNAME") ".MNU"))
  300.       fp (open fname "r")
  301.      );setq
  302.      (while (/= (read-line fp) "***POP0"))
  303.      (while (not (wcmatch (setq line (read-line fp)) "`**"))
  304.     (setq count 0 flag nil)
  305.     (repeat (length osnlist)
  306.         (setq word (nth count osnlist)
  307.           line (strcase line)
  308.           count (1+ count)
  309.         );setq
  310.         (if (wcmatch line (strcat "*" word "*"))
  311.         (setq snlist (append snlist (list word)) flag T)
  312.         );if
  313.     );repeat
  314.     (if (not flag) (setq snlist (append snlist (list ""))))
  315.      );while
  316.  
  317.      (if (not dcl_q)
  318.           (setq dcl_q (load_dialog "QDIM.DCL"))
  319.      );setq
  320.      (setvar "CMDECHO" 0)
  321.      (setvar "UNITMODE" 0)
  322.      (setvar "TEXTEVAL" 1)
  323.  
  324.      (setq num 0)
  325.      (if (not (wcmatch (getvar "CLAYER") "*DIM*"))
  326.           (setq lalist (list (getvar "CLAYER")))
  327.      );if
  328.  
  329.      (tblnext "LAYER" T)
  330.      (while (setq opt (tblnext "LAYER"))
  331.           (setq opta (dxf 2 opt))
  332.           (if (wcmatch opta "*DIM*")
  333.                (setq lalist (append lalist (list opta))
  334.                     num (1+ num)
  335.                );setq
  336.           );if
  337.           (if (and (= opta "FLR_DIM") (not P_LIND))
  338.                (setq P_LIND num)
  339.           );if
  340.      );while
  341.      (if (not P_LIND) (setq P_LIND 0))
  342.      (if (> P_LIND (- (length lalist) 1)) (setq P_LIND (prompt "PL overflow") P_LIND 0))
  343.  
  344.      (if (not P_DIND) (setq P_DIND 0))
  345.      (setq num nil)
  346.      (while (setq num (tblnext "DIMSTYLE" (not num)))
  347.           (setq dlist (append dlist (list (dxf 2 num))))
  348.      );while
  349.  
  350.      (if (not (member (getvar "DIMSTYLE") dlist))
  351.     (setq dlist (append (list (getvar "DIMSTYLE")) dlist))
  352.      );if
  353.      (if (> P_DIND (1- (length dlist))) (setq P_DIND (1- (length dlist))))
  354.      (grtext -1 (strcat "Layer: " (nth P_LIND lalist) "  Style: " (nth P_DIND dlist)))
  355. );defun
  356.  
  357.  
  358. (defun base_pick ( / en ed)
  359.     (setq en (car (entsel)))
  360.     (if en (setq ed (entget en)))
  361.     (if (= (dxf 0 ed) "DIMENSION")
  362.     (setq   P_QBPT (dxf 10 ed)
  363.         P_QBAN (angle (dxf 10 ed) (dxf 14 ed))
  364.         P_QBSN T
  365.     );setq
  366.     );if
  367. );defun
  368.  
  369. ;;;SNAPTO is invoked when a line of text is completed within the QDIM loop.
  370. ;;;It determines whether it is valid input, then sets the BOX to 2
  371. ;;;which causes the grread to draw a pick box
  372. (defun snapto ()
  373.      (if     (or (= (strcase tx) "NEA")
  374.                (= (strcase tx) "INT")
  375.                (= (strcase tx) "PER")
  376.           );or
  377.  
  378.           (progn
  379.                (prompt " to: ")
  380.                (setq box 2)
  381.           );progn
  382.  
  383.           (progn
  384.                (prompt "\nInvalid option")
  385.                (prompt "\nLocate third point: ")
  386.                (setq  tx ""
  387.                     gd (grread T)
  388.                );setq
  389.           );progn
  390.      );if
  391. );defun
  392.  
  393. ;;;ORIENT determines where to draw guidelines based on the mode (HOR, VERT or
  394. ;;;ALIgned) that QDIM is in
  395. (defun orient ()
  396.      (if P_QBSN
  397.     (progn
  398.         (setq ptz (inters P_QBPT (polar P_QBPT (+ (* pi 0.5) P_QBAN) 1)
  399.                 ptp (polar ptp P_QBAN 1) nil
  400.             );inters
  401.         );setq
  402.         (if (< (distance ptp ptz) 20.0) (setq ptp ptz))
  403.     );progn
  404.     );if
  405.  
  406.      (cond
  407.           ((or (and     (> (car ptp) (car pt1))
  408.                          (< (car ptp) (car pt2))
  409.                          (> (cadr ptp) (cadr ptl))
  410.                          (< (cadr ptp) (cadr pth))
  411.                          (= aforc 0)
  412.                     );and
  413.                     (= aforc 1)
  414.                );or
  415.  
  416.                (setq pta (inters  pt1 (polar pt1 angl 1)
  417.                          ptp (polar ptp angp 1)
  418.                          nil
  419.                     );inters
  420.                     ptb (inters   pt2 (polar pt2 angl 1)
  421.                          ptp (polar ptp angp 1)
  422.                          nil
  423.                     );inters
  424.                     mode "ALIGN"
  425.                );setq
  426.           );align mode
  427.  
  428.           ((or   (and (> ang (angle ptm pt4)) (< ang (angle ptm pt1)) (= aforc 0))
  429.                     (and (> ang (angle ptm pt3)) (< ang (angle ptm pt2)) (= aforc 0))
  430.                     (and (> ang (angle ptm pt2)) (< ang (angle ptm pt3)) (= aforc 0))
  431.                     (and (> ang (angle ptm pt1)) (< ang (angle ptm pt4)) (= aforc 0))
  432.                     (and (= (cadr pt1) (cadr pt2)) (= aforc 0))
  433.                     (= aforc 2)
  434.                );or
  435.  
  436.                (setq pta (list (car pt1) (cadr ptp))
  437.                     ptb (list (car pt2) (cadr ptp))
  438.                     mode "HOR"
  439.                );setq
  440.           );horizontal mode 
  441.  
  442.           (ptp (setq pta (list (car ptp) (cadr pt1))
  443.                     ptb (list (car ptp) (cadr pt2))
  444.                     mode "VERT"
  445.                );setq
  446.           );vertical mode
  447.      );cond OVERALL
  448. );defun orient
  449.  
  450. ;;;QDDRAW determines whether DMDRAW needs to be called.  If so
  451. ;;;it resets the old variables (which begin with o) for future erasure
  452. (defun qddraw ()
  453.      (if (or (not (equal opt ptp)) (/= aforc oaforc))
  454.           (progn
  455.                (dmdraw pt1 opta optb pt2)
  456.                (dmdraw pt1 pta ptb pt2)
  457.                (grtext -1 (strcat "Layer: " (nth P_LIND lalist) "  Style: " (nth P_DIND dlist) "  Mode: " mode ftxt))
  458.                (setq opt ptp              
  459.                     opta pta
  460.                     optb ptb
  461.                     oaforc aforc
  462.                );setq
  463.           );progn
  464.      );if
  465. );defun
  466.  
  467. (defun force ()
  468.      (cond
  469.           ((= (get_tile "aligned") "1")
  470.                (setq aforc 1)
  471.           )
  472.  
  473.           ((= (get_tile "horizontal") "1")
  474.                (setq aforc 2)
  475.           )
  476.  
  477.           ((= (get_tile "vertical") "1")
  478.                (setq aforc 3)
  479.           )
  480.  
  481.           (T (setq aforc 0))
  482.      );cond
  483.      (if (> aforc 0)
  484.           (setq ftxt "<--F")
  485.           (setq ftxt "")
  486.      );if
  487. );defun
  488.  
  489. (defun dxf (code elist)
  490.     (cdr (assoc code elist))
  491. );defun
  492.  
  493. (if AUTO_RUN
  494.   (progn
  495.     (setq AUTO_RUN nil)
  496.     (C:qdim)
  497.   );progn
  498. );if